unit uDZThread;

interface

uses
  SysUtils, Windows, ActiveX, uDZSysUtils;

const
  (**********************************************************************
  Thread status
  STATE_UNINITIALIZED: Thread hasn't been created yet
  STATE_RUNNING: Thread is running
  STATE_SUSPENDED: Thread is suspended
  STATE_TERMINATED: Thread is terminated,but its handle not released
  **********************************************************************)
  STATE_UNINITIALIZED: LongInt = 0;
  STATE_RUNNING: LongInt       = 1;
  STATE_SUSPENDED: LongInt     = 2;
  STATE_TERMINATED: LongInt    = 3;

type
  LPTHREAD_START_ROUTINE = function(lpThreadParameter: Pointer): DWORD; stdcall;

  TDzThreadOption = (tdUseCOM, tdStopSignal);
  TDzThreadOptions = set of TDzThreadOption;

  TDzThread = class(TObject)
  private
    fOptions: TDzThreadOptions;
    fThreadParameter: Pointer;
    fThreadId: DWORD;              (* threadid *)
    fHandle: THandle;        (* Thread handle *)
    fExitCode: DWORD;              (* the Thread function returns *)
    fFreeOnTerminate: Boolean;
    fStopSignal: THandle;
    fStopped: Boolean;
    procedure ThreadEntry;
    function ThreadExecuting: Boolean;
  protected
    procedure Execute; virtual; abstract;
  public
    constructor Create(param: Pointer); overload;
    constructor Create(param: Pointer; _options: TDzThreadOptions); overload; virtual;
    destructor Destroy; override;
    function Start: Boolean;
    procedure Terminate(code: DWORD = DWORD(-1));
    procedure Suspend;
    procedure Resume(untilRun: Boolean);
    procedure ReleaseThread;
    procedure Stop; virtual;
    procedure StopAndWait;
    function WaitForStopSignal(timeout: DWORD = INFINITE): Boolean;
    function WaitForMultipleObjects(nCount: DWORD;
      lpHandles: PWOHandleArray; timeout: DWORD = INFINITE): DWORD;
    function WaitForTerminate(timeout: DWORD = INFINITE): Boolean;
    property Executing: Boolean read ThreadExecuting;
    property Options: TDzThreadOptions read fOptions;
    property ThreadParameter: Pointer read fThreadParameter;
    property ThreadId: DWORD read fThreadId;
    property Handle: THandle read fHandle;
    property ExitCode: DWORD read fExitCode write fExitCode;
    property Stopped: Boolean read fStopped write fStopped;
    property StopSignal: THandle read fStopSignal;
    property FreeOnTerminate: Boolean read fFreeOnTerminate write fFreeOnTerminate;
  end;

type
  ISynchronous = interface(IDzBaseInterface)
    function Acquire(WaitTimeout: LongWord): Boolean;
    procedure Release(Count: Integer); overload;
    procedure Release; overload;
  end;

  TDzEvent = class(TDzInterfacedObject, ISynchronous)
  private
    fHandle: THandle;
  public
    constructor Create(const Name: string; InitState, ManualReset: Boolean);
    destructor Destroy; override;
    function Acquire(WaitTimeout: LongWord = INFINITE): Boolean;
    procedure Release; overload;
    procedure Release(Count: Integer); overload;
  end;

  TDzCriticalSection = class(TDzInterfacedObject, ISynchronous)
  private
    fCriticalSection: TRTLCriticalSection;
  public
    constructor Create; overload;
    constructor Create(SpinCount: DWORD); overload;
    destructor Destroy; override;
    function Acquire(WaitTimeout: LongWord = INFINITE): Boolean;
    function TryAcquire: Boolean;
    procedure Release; overload;
    procedure Release(Count: Integer); overload;
  end;

  TDzDeadLoopLock = class(TDzInterfacedObject, ISynchronous)
  private
    fState: Longint;
  public
    function Acquire(WaitTimeout: LongWord = INFINITE): Boolean;
    function TryAcquire: Boolean;
    procedure Release; overload;
    procedure Release(Count: Integer); overload;  
  end;

  TDzSemaphore = class(TDzInterfacedObject, ISynchronous)
  private
    fHandle: THandle;
  public
    constructor Create(const Name: string; initCount, maxCount: Integer);
    destructor Destroy; override;
    function Acquire(WaitTimeout: LongWord = INFINITE): Boolean;
    procedure Release; overload;
    procedure Release(Count: Integer); overload;
  end;

procedure CreateAnonymousThread(Code: TProcedure);

implementation

type
  TAnonymousThread = class(TDzThread)
  protected
    procedure Execute; override;
  end;

{ TAnonymousThread }

procedure TAnonymousThread.Execute;
begin
  TProcedure(ThreadParameter)();
end;
  
procedure CreateAnonymousThread(Code: TProcedure);
var
  Thread: TAnonymousThread;
begin
  Thread := TAnonymousThread.Create(Pointer(@Code));
  Thread.FreeOnTerminate := True;
  Thread.Start;
end;

function ThreadProc(lpThreadParameter: PAnsiChar): DWORD; stdcall;
var
  Thread: TDzThread;
begin
  Thread := TDzThread(lpThreadParameter);
  Thread.ThreadEntry;
  Result := Thread.ExitCode;
  if Thread.FreeOnTerminate then Thread.Free;
end;

{ TDzThread }

constructor TDzThread.Create(param: Pointer);
begin
  Create(param, []);
end;

constructor TDzThread.Create(param: Pointer; _options: TDzThreadOptions);
begin
  inherited Create;
  fThreadId := 0;
  fHandle := 0;
  fExitCode := 0;
  fThreadParameter := param;
  fOptions := _options;
  if tdStopSignal in _options then
    fStopSignal := CreateEvent(nil, False, False, nil)
  else fStopSignal := 0;
  fStopped := False;
end;

destructor TDzThread.Destroy;
begin
  if fStopSignal <> 0 then CloseHandle(fStopSignal);
  inherited;
end;

function TDzThread.Start: Boolean;
begin
  if ThreadExecuting then
  begin
    Result := True;
    Exit;
  end;

  ReleaseThread;

  fStopped := False;
  if fStopSignal <> 0 then
    ResetEvent(fStopSignal);

  fHandle := Windows.CreateThread(nil, 0, @ThreadProc, Self, 0, fThreadId);
    
  Result := fHandle <> 0;
end;

procedure TDzThread.Stop;
begin
  fStopped := True;
  if fStopSignal <> 0 then SetEvent(fStopSignal);
end;

procedure TDzThread.Terminate(code: DWORD);
begin
  if ThreadExecuting then
  begin
    TerminateThread(fHandle, code);
    TerminateThread(fHandle, code);
    CloseHandle(fHandle);
    fHandle := 0;
    fThreadId := 0;
  end;
end;

procedure TDzThread.Suspend;
begin
  SuspendThread(fHandle);
end;

procedure TDzThread.Resume(untilRun: Boolean);
var
  SuspendCount:DWORD;
begin
  if Executing then
  begin
    SuspendCount := Windows.ResumeThread(fHandle);
    if untilRun then
    begin
      while (SuspendCount > 1) and (SuspendCount <> $FFFFFFFF) do
        SuspendCount := Windows.ResumeThread(fHandle);
    end;
  end;
end;

procedure TDzThread.ReleaseThread;
var
  code: DWORD;
begin
  if (fThreadId <> 0) and (GetExitCodeThread(fHandle, code)) and
    (code <> STILL_ACTIVE) then
  begin
    CloseHandle(fHandle);
    fHandle := 0;
    fThreadId := 0;
  end;
end;

function TDzThread.WaitForMultipleObjects(nCount: DWORD;
  lpHandles: PWOHandleArray; timeout: DWORD): DWORD;
var
  handles: array [0..MAXIMUM_WAIT_OBJECTS - 1] of THandle;
  i: Integer;
  wr: DWORD;
begin
  if (fStopSignal = 0) then
  begin
    Result := Windows.WaitForMultipleObjects(nCount, @handles, False, timeout);
    Exit;
  end;

  handles[0] := fStopSignal;
  for i := 0 to nCount - 1 do handles[i + 1] := lpHandles^[i];

  wr := Windows.WaitForMultipleObjects(nCount + 1, @handles, False, timeout);

  if (wr = WAIT_OBJECT_0) then
  begin
    fStopped := True;
    Result := WAIT_TIMEOUT;
  end
  else if (wr > WAIT_OBJECT_0) and (wr <= WAIT_OBJECT_0 + nCount) then
    Result := wr - 1
  else Result := wr;
end;

function TDzThread.WaitForStopSignal(timeout: DWORD): Boolean;
begin
  if (fStopSignal = 0) then
    raise Exception.Create('tdStopSignal option is not set for this Thread!');
  case WaitForSingleObject(fStopSignal, timeout) of
    WAIT_TIMEOUT: Result := False;
    else Result := True;  
  end;
end;

function TDzThread.WaitForTerminate(timeout: DWORD): Boolean;
begin
  if fHandle <> 0 then
  begin
    Result := WaitForSingleObject(fHandle, timeout) <> WAIT_TIMEOUT;
    if Result then ReleaseThread;
  end
  else Result := True;
end;

procedure TDzThread.ThreadEntry;
begin
  IsMultiThread := True;
  if tdUseCOM in fOptions then CoInitialize(nil);
  Execute;
  if tdUseCOM in fOptions then CoUninitialize;
end;

function TDzThread.ThreadExecuting: Boolean;
var
  v: DWORD;
begin
  Result := (fHandle <> 0) and GetExitCodeThread(fHandle, v) and
    (v = STILL_ACTIVE);
end;

procedure TDzThread.StopAndWait;
begin
  Stop;
  WaitForTerminate(INFINITE);
end;

{ TDzSemaphore }

constructor TDzSemaphore.Create(const Name: string; initCount, maxCount: Integer);
begin
  fHandle := CreateSemaphore(nil, initCount, maxCount, PChar(Name));
end;

destructor TDzSemaphore.Destroy;
begin
  Windows.CloseHandle(fHandle);
end;

procedure TDzSemaphore.Release;
begin
  Windows.ReleaseSemaphore(fHandle, 1, nil);
end;

procedure TDzSemaphore.Release(Count: Integer);
begin
  Windows.ReleaseSemaphore(fHandle, Count, nil);
end;

function TDzSemaphore.Acquire(WaitTimeout: LongWord): Boolean;
begin
  Result := WaitForSingleObject(fHandle, WaitTimeout) = WAIT_OBJECT_0;
end;

{ TDzEvent }

function TDzEvent.Acquire(WaitTimeout: LongWord): Boolean;
begin
  Result := WaitForSingleObject(fHandle, WaitTimeout) = WAIT_OBJECT_0;  
end;

constructor TDzEvent.Create(const Name: string; InitState, ManualReset: Boolean);
begin
  fHandle := Windows.CreateEvent(nil, ManualReset, InitState, PChar(Name));
end;

destructor TDzEvent.Destroy;
begin
  Windows.CloseHandle(fHandle);
  inherited;
end;

procedure TDzEvent.Release(Count: Integer);
begin
  
end;

procedure TDzEvent.Release;
begin

end;

{ TDzCriticalSection }

function TDzCriticalSection.Acquire(WaitTimeout: LongWord): Boolean;
begin
  Windows.EnterCriticalSection(fCriticalSection);
  Result := True;
end;

constructor TDzCriticalSection.Create;
begin
  Windows.InitializeCriticalSection(fCriticalSection);
end;

constructor TDzCriticalSection.Create(SpinCount: DWORD);
begin
  Windows.InitializeCriticalSectionAndSpinCount(fCriticalSection, SpinCount);
end;

destructor TDzCriticalSection.Destroy;
begin
  Windows.DeleteCriticalSection(fCriticalSection);
  inherited;
end;

procedure TDzCriticalSection.Release(Count: Integer);
begin
  Windows.LeaveCriticalSection(fCriticalSection);
end;

function TDzCriticalSection.TryAcquire: Boolean;
begin
  Result := TryEnterCriticalSection(fCriticalSection);
end;

procedure TDzCriticalSection.Release;
begin
  Windows.LeaveCriticalSection(fCriticalSection);
end;

{ TDzDeadLoopLock }

function TDzDeadLoopLock.Acquire(WaitTimeout: LongWord): Boolean;
var
  tick: DWORD;
begin
  Result := False;
  tick := GetTickCount;
  repeat
    if InterlockedExchange(fState, 1) = 0 then
    begin
      Result := True;
      Exit;
    end;
  until
    GetTickCount - tick > WaitTimeout;
end;

procedure TDzDeadLoopLock.Release;
begin
  InterlockedExchange(fState, 0);
end;

procedure TDzDeadLoopLock.Release(Count: Integer);
begin
  InterlockedExchange(fState, 0);
end;

function TDzDeadLoopLock.TryAcquire: Boolean;
begin
  Result := InterlockedExchange(fState, 1) = 0;  
end;

end.
